;;; -*- Mode:LISP; Package:SI; Base:10; Readtable:ZL -*-

;;; Readtable for Common Lisp.

(EVAL-WHEN (COMPILE LOAD EVAL)
  (FERROR NIL "If you are compiling or loading this, and not using RTC, you are losing!"))

(:MAC DIGIT '(// #/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
      EXTENDED-DIGIT '(// -11)                          ;-11 is extended digit syntax.
      ILLEGAL '(// -12)                                 ;-12 is "illegal token constituent"
                                                        ;which is what Return or Space become
                                                        ;if made into symbol constituents.
      PLUS-MINUS '(// #/+ #/-)
      PLUS #/+
      POINT #/.
      SLASH #//
      BACKSLASH #/\
      VBAR #/|
      CIRCLECROSS #/
      EE '(// #/E #/e)
      SS '(// #/S #/s)
      DDLLFF '(// #/L #/l #/D #/d #/F #/f)
      EXTENSION-CHAR '(// #/^ #/_)
      SHARP-SIGN #/#
      COLON #/:
      NULL '(//)
      QUOTED-CHAR -1                                    ;Quoted chars to be mapepd to -1.
      EOF-CHAR -2                                       ;EOF is mapped to -2.
      WHITE-SPACE-CHAR '(// #/SP #/TAB #/LINE #/PAGE #/CR -5)   ;-5 IS WHITESPACE SYNTAX
      BREAK (NCONC '(// #/( #/) #/' #/` #/, #/" #/; #/ -2 -3 -4 -6)    ;-3 IS BREAK SYNTAX
                   (CDR WHITE-SPACE-CHAR))
      MACRO-CHARACTER '(// #/' #/, #/; #/` #/# #/( #/) #/" #/ -6 -10)
                                                        ;-6 is macro syntax,
                                                        ;-10 nonterminating macro syntax.
      STANDALONE-CHAR '(// -4)                          ;-4 is single syntax
      ANY (CONS '// (DO ((I -11 (1+ I))                 ;-7 is alphabetic syntax
                         (X NIL (CONS I X)))            ;Note ANY does not include -12.
                        ((= I SI:RDTBL-ARRAY-SIZE) X)))
      ANY-BUT-EOF (DELETE -2 ANY)
      LETTER (APPEND '(// -11)
                     (DO ((I #/A (1+ I))
                          (X NIL))
                         ((> I #/Z) X)
                       (PUSH I X))
                     (DO ((I #/a (1+ I))
                          (X NIL))
                         ((> I #/z) X)
                       (PUSH I X)))

      PACKAGE-NAME '(:* (:- ANY-BUT-EOF (:U COLON BREAK)))

      SIGN? '(U NULL PLUS-MINUS)
      POTENTIAL-NUMBER-INSIDES '(:! (:* (:U DIGIT POINT EXTENSION-CHAR SLASH PLUS-MINUS))
                                    (:* (:! LETTER
                                            (:+ (:U DIGIT POINT EXTENSION-CHAR
                                                    SLASH PLUS-MINUS))))
                                    (:U NULL LETTER))
      POTENTIAL-NUMBER-END '(:! (:* (:U DIGIT POINT EXTENSION-CHAR
                                        SLASH PLUS-MINUS))
                                (:* (:! LETTER
                                        (:+ (:U DIGIT POINT EXTENSION-CHAR
                                                SLASH PLUS-MINUS))))
                                (:U LETTER
                                    (:! LETTER
                                        (:U DIGIT POINT EXTENSION-CHAR SLASH))
                                    DIGIT POINT EXTENSION-CHAR SLASH))
      POTENTIAL-NUMBER-NO-POINTS-INSIDES
                           '(:! (:* (:U DIGIT EXTENDED-DIGIT EXTENSION-CHAR SLASH PLUS-MINUS))
                                (:* (:! LETTER
                                        (:+ (:U DIGIT EXTENDED-DIGIT EXTENSION-CHAR
                                                SLASH PLUS-MINUS))))
                                (:U NULL LETTER))
      POTENTIAL-NUMBER-NO-POINTS-END
                           '(:! (:* (:U DIGIT EXTENDED-DIGIT EXTENSION-CHAR
                                        SLASH PLUS-MINUS))
                                (:* (:! LETTER
                                        (:+ (:U DIGIT EXTENDED-DIGIT EXTENSION-CHAR
                                                SLASH PLUS-MINUS))))
                                (:U LETTER
                                    (:! LETTER
                                        (:U DIGIT EXTENDED-DIGIT EXTENSION-CHAR SLASH))
                                    DIGIT EXTENDED-DIGIT EXTENSION-CHAR SLASH))

      RTC-FIXNUM '(:! (:+ (:U DIGIT EXTENDED-DIGIT))
                      (:U NULL POINT))
      RTC-FLOAT-NO-EXP '(:! (:* DIGIT)
                            POINT
                            (:+ DIGIT))
      RTC-DECNUM '(:! (:+ DIGIT)
                      (:U NULL POINT))
      RTC-FLONUM '(:! (:U (:! RTC-FLOAT-NO-EXP
                              (:U NULL
                                  (:! EE
                                      SIGN?
                                      (:+ DIGIT))))
                          (:! RTC-DECNUM
                              EE
                              SIGN?
                              (:+ DIGIT))))
      RTC-SMALL-FLONUM '(:! (:U RTC-FLOAT-NO-EXP
                                RTC-DECNUM)
                            SS
                            SIGN?
                            (:+ DIGIT))
      RTC-SINGLE-FLONUM '(:! (:U RTC-FLOAT-NO-EXP
                                 RTC-DECNUM)
                             DDLLFF
                             SIGN?
                             (:+ DIGIT))
      RTC-RATIONAL '(:! (:+ (:U DIGIT EXTENDED-DIGIT))
                        SLASH
                        (:+ (:U DIGIT EXTENDED-DIGIT)))
      )

;;; A readtable definition looks like (DEF name regular-expression type).
;;; "name" is the name of the kind of token.  It has a function to process the
;;;   string, on its property list, OR it is a symbol to be returned.
;;; "regular-expression" is a regular expression.
;;; "type" is a symbol indicating what to do with the last character
;;; recognized by the regular expression.

;; First, numbers.  Anything that looks like a number really is one,
;; so these can be first; and they must precede SYMBOL
;; since all numbers would be symbols if they weren't numbers.
(:DEF FIXNUM
      (:! SIGN?
         RTC-FIXNUM
         BREAK)
  UNTYI-FUNCTION)

(:DEF FLOAT
      (:! SIGN?
          RTC-FLONUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF SHORT-FLOAT
      (:! SIGN?
          RTC-SMALL-FLONUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF SINGLE-FLOAT
      (:! SIGN?
          RTC-SINGLE-FLONUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF RATIONAL
      (:! SIGN?
          RTC-RATIONAL
          BREAK)
  UNTYI-FUNCTION)

(:DEF SHARP-PACKAGE-PREFIX
      (:! PACKAGE-NAME SHARP-SIGN COLON)
  LAST-CHAR)

(:DEF CONSING-DOT
      (:! POINT BREAK)
  UNTYI-QUOTE)

(:DEF MULTI-DOT
     (:! (:+ POINT) BREAK)
  UNTYI-FUNCTION)

(:DEF EOF EOF-CHAR NO-UNTYI-QUOTE)

(:DEF MACRO-CHAR
      MACRO-CHARACTER
  LAST-CHAR)

(:DEF SC-SYMBOL
      STANDALONE-CHAR
  NO-UNTYI-FUNCTION)

(:DEF PACKAGE-PREFIX
      (:! PACKAGE-NAME COLON)
  LAST-CHAR)

;;; This includes anything that Common Lisp might someday define to be a kind of number.
;;; If something gets this far, it isn't actually a number, so it will be read as a symbol.
;;; But it will be quoted when printed for the sake of other Common Lisp
;;; systems in which it might be a number.
(:DEF POTENTIAL-NUMBER
      (:! (:U DIGIT
              (:! (:U DIGIT PLUS-MINUS POINT EXTENSION-CHAR)
                  POTENTIAL-NUMBER-INSIDES
                  DIGIT
                  POTENTIAL-NUMBER-END)
              ;; Degenerate cases: if first or last is a digit,
              ;; we don't need to insist on a digit somewhere inside.
              (:! DIGIT
                  POTENTIAL-NUMBER-END)
              (:! (:U DIGIT PLUS-MINUS POINT EXTENSION-CHAR)
                  POTENTIAL-NUMBER-INSIDES
                  DIGIT)
              ;; Now an analogous set of cases, which allow extended digits but not points.
              EXTENDED-DIGIT
              (:! (:U DIGIT EXTENDED-DIGIT PLUS-MINUS EXTENSION-CHAR)
                  POTENTIAL-NUMBER-NO-POINTS-INSIDES
                  (:U DIGIT EXTENDED-DIGIT)
                  POTENTIAL-NUMBER-NO-POINTS-END)
              ;; Degenerate cases: if first or last is a digit,
              ;; we don't need to insist on a digit somewhere inside.
              (:! (:U DIGIT EXTENDED-DIGIT)
                  POTENTIAL-NUMBER-NO-POINTS-END)
              (:! (:U DIGIT EXTENDED-DIGIT PLUS-MINUS EXTENSION-CHAR)
                  POTENTIAL-NUMBER-NO-POINTS-INSIDES
                  (:U DIGIT EXTENDED-DIGIT)))
          BREAK)
  UNTYI-FUNCTION)

;;; These are never reached, since slash and vbar are caught at a low level
;;; and only serve to quote other characters.  However,
;;; these do cause slash and vbar to have unique read syntaxes,
;;; which is how the low level checks for them.
(:DEF :CHARACTER-CODE-ESCAPE CIRCLECROSS NO-UNTYI-FUNCTION)
(:DEF :ESCAPE BACKSLASH NO-UNTYI-FUNCTION)
(:DEF :MULTIPLE-ESCAPE VBAR NO-UNTYI-FUNCTION)

;;; Must be last.
(:DEF SYMBOL
      (:! (:* (:- ANY-BUT-EOF BREAK))
          BREAK)
  UNTYI-FUNCTION)

(:DEF SYMBOL-ILLEGAL
      (:! (:+ (:U (:- ANY-BUT-EOF BREAK) ILLEGAL))
          BREAK)
  UNTYI-FUNCTION)

(:OPT :WHITE-SPACE-CHAR (CDR WHITE-SPACE-CHAR))                 ;Options to RTC
(:OPT :MACRO-ALIST '((#/" XR-DOUBLEQUOTE-MACRO)
                     (#/( XR-OPENPAREN-MACRO)
                     (#/) XR-CLOSEPAREN-MACRO)
                     (#/' XR-QUOTE-MACRO)
                     (#/; XR-COMMENT-MACRO)
                     (#/` XR-BACKQUOTE-MACRO)
                     (#/, XR-COMMA-MACRO)
                     (#/# XR-DISPATCH-MACRO-DRIVER T
                      (#/' XR-#/'-MACRO)
                      (#/` XR-#/`-MACRO)
                      ;>>No! (#/ XR-#-MACRO)
                      (#/\ XR-CL-#\-MACRO)
                      (#/^ XR-#^-MACRO)
                      (#/, XR-#/,-MACRO)
                      (#/. XR-#.-MACRO)
                      (#/: XR-#/:-MACRO)
                      (#/= XR-#=-MACRO)
                      (#/# XR-##-MACRO)
                      (#/ XR-#-MACRO)
                      (#/( XR-#/(-MACRO)
                      (#/* XR-#*-MACRO)
                      (#/A XR-#A-MACRO)
                      (#/S XR-#S-MACRO)
                      (#/C XR-#C-MACRO)
                      ;>> if you are using one of the next three, you are losing anyway
                      ; (#/Q XR-#Q-MACRO)
                      ; (#/M XR-#M-MACRO)
                      ; (#/N XR-#N-MACRO)
                      (#/+ XR-#+-MACRO)
                      (#/- XR-#--MACRO)
                      (#/B XR-#B-MACRO)
                      (#/O XR-#O-MACRO)
                      (#/R XR-#R-MACRO)
                      (#/X XR-#X-MACRO)
                      (#/ INFIX-TOPLEVEL-PARSE)
                      (#/| XR-#/|-MACRO)
                      (#/! XR-#!-MACRO) ;; not common-lisp, but we need this for patch files.
                      )))
(:OPT :READ-FUNCTION-PROPERTY 'STANDARD-READ-FUNCTION)
;; The next two are redundant.  They set different variables, but must match.
;(:OPT :QUOTE #/\)
(:OPT :ESCAPE BACKSLASH)
(:OPT :MULTIPLE-ESCAPE VBAR)
;; The next two are redundant.  They set different variables, but must match.
;(:OPT CIRCLECROSS #/)
(:OPT :CHARACTER-CODE-ESCAPE CIRCLECROSS)
(:OPT :QUOTED-CHAR QUOTED-CHAR)
(:OPT :EOF-CHAR EOF-CHAR)
(:OPT :A-BREAK-CHAR -3)                                 ;For the reader to use.
(:OPT :MAKE-SYMBOL '(SC-SYMBOL))                        ;Who makes symbols
(:OPT :MAKE-SYMBOL-BUT-LAST '(SYMBOL))                  ;and how.
(:OPT :BITS '((#/" #o10)))                              ;Bits to be ored into readtable.
(:OPT :SAVE-SYNTAX '(SINGLE -4                          ;Placed in plist of readtable
                     QUOTE #/\                          ; with syntax bits replacing
                     ESCAPE #/\                         ; character numbers.
                     MULTIPLE-ESCAPE #/|
                     RATIO #//
                     CIRCLECROSS #/
                     CHARACTER-CODE-ESCAPE #/
                     WHITESPACE -5
                     MACRO -6
                     NON-TERMINATING-MACRO -10
                     BREAK -3
                     ALPHABETIC -7
                     ILLEGAL -12
                     EXTENDED-DIGIT -11
                   ))
(:OPT :TRANSLATIONS '(((#/a  #/z)  (#/A  #/Z))))        ;Translations may be pairs of
                                                        ;intervals (inclusive) or just chars

(:OPT :PTTBL-SLASH #/\)
(:OPT :PTTBL-CHARACTER '("#" . "\"))
(:OPT :PTTBL-RATIONAL-INFIX #//)
(:OPT :PTTBL-COMPLEX '("#C(" " " ")"))
;;; Also don't forget to update the cruft in the function SI::PKG-INITIALIZE
(:OPT :SYMBOL-SUBSTITUTIONS
     '((// . CLI://)
       (*DEFAULT-PATHNAME-DEFAULTS* . CL:*DEFAULT-PATHNAME-DEFAULTS*)
       (GLOBAL:AR-1 . CL:AR-1)
       (GLOBAL:AR-1-FORCE . CL:AR-1-FORCE)
       (GLOBAL:AREF . CL:AREF)
       (GLOBAL:ASSOC . CL:ASSOC)
       (GLOBAL:ATAN . CL:ATAN)
       (CHARACTER . CL:CHARACTER)
       (GLOBAL:CLOSE . CL:CLOSE)
       (GLOBAL:DEFSTRUCT . CL:DEFSTRUCT)
       (GLOBAL:DELETE . CL:DELETE)
       (GLOBAL:EVERY . CL:EVERY)
       (GLOBAL:FUNCTIONP . CL:FUNCTIONP)
       (GLOBAL:GETHASH . CL:GETHASH)
       (GLOBAL:IF . CL:IF)
       (GLOBAL:INTERSECTION . CL:INTERSECTION)
       (GLOBAL:LISTP . CL:LISTP)
       (GLOBAL:MAKE-ARRAY . CL:MAKE-ARRAY)
       (GLOBAL:MAKE-PACKAGE . CL:MAKE-PACKAGE)
       (GLOBAL:MAP . CL:MAP)
       (GLOBAL:MEMBER . CL:MEMBER)
       (GLOBAL:NINTERSECTION . CL:NINTERSECTION)
       (GLOBAL:NLISTP . CLI:NLISTP) ;cli, not cl
       (GLOBAL:NUNION . CL:NUNION)
       (GLOBAL:RASSOC . CL:RASSOC)
       (GLOBAL:READ . CL:READ)
       (GLOBAL:READ-FROM-STRING . CL:READ-FROM-STRING)
       (GLOBAL:REM . CL:REM)
       (GLOBAL:REMOVE . CL:REMOVE)
       (GLOBAL:SOME . CL:SOME)
       (GLOBAL:SUBST . CL:SUBST)
       (GLOBAL:TIME . CL:TIME)
       (GLOBAL:UNION . CL:UNION))
     )
(:OPT :NAMES '("standard Common-Lisp" "CL" "Common-Lisp" "Generic" "Plebian"))
(:OPT :PROPERTIES '(:SYNTAX :COMMON-LISP))

(:END COMMON-LISP-READTABLE)                            ;The symbol whose value cell will
                                                        ;be loaded with the readtable
